( prodos file system )

( common directory entry fields )

struct
  byte%      field pentry>storage_type
  byte% $f * field pentry>file_name
end-struct pentry%

( common header fields )

pentry%
  byte% $8 * field pheader>reserved
  long%      field pheader>creation
  byte%      field pheader>version
  byte%      field pheader>min_version
  byte%      field pheader>access
  byte%      field pheader>entry_length
  byte%      field pheader>entries_per_block
  word%      field pheader>file_count
end-struct pheader%

( volume directory header )

pheader%
  word%      field pvolume>bit_map_pointer
  word%      field pvolume>total_blocks
end-struct pvolume%

( subdirectory header )

pheader%
  word%      field pdirectory>parent_pointer
  byte%      field pdirectory>parent_entry_number
  byte%      field pdirectory>parent_entry_length
end-struct pdirectory%

( file entry )

pentry%
  byte%      field pfile>file_type
  word%      field pfile>key_pointer
  word%      field pfile>blocks_used
  tri%       field pfile>eof
  long%      field pfile>creation
  byte%      field pfile>version
  byte%      field pfile>min_version
  byte%      field pfile>access
  word%      field pfile>aux_type
  long%      field pfile>last_mod
  word%      field pfile>header_pointer
end-struct pfile%

( directory block )

struct
  word% field pdir_block>prev
  word% field pdir_block>next

end-struct pdir_block%

( storage types )

$00 constant storage_type.inactive
$10 constant storage_type.seedling
$20 constant storage_type.sapling
$30 constant storage_type.tree
$40 constant storage_type.pascal
$d0 constant storage_type.file
$e0 constant storage_type.directory
$f0 constant storage_type.volume

( access attributes )

$80 constant access.destroy
$40 constant access.rename
$20 constant access.backup
$02 constant access.write
$01 constant access.read

access.destroy
access.rename  or
access.backup  or
access.write   or
access.read    or
  constant access.all

( block operations )

\ block size
$200 constant pblock%

\ length of n blocks
: pblocks ( pblocks -- bytes )
  pblock% * ;

\ convert taddress to block number
: ta>pblock ( ta -- pblock )
  ta>offset pblock% / ;

\ block number of current address
: current-pblock ( -- pblock )
  there ta>pblock ;

( boot blocks )

\ write boot blocks
: pboot ( -- )
  $2 pblocks $0 ?do $00 t1, loop ;

( directory block )

\ prev/next pointers
: pdir-only   ( -- )                    $0000 t2, $0000 t2, ;
: pdir-first  ( -- ) current-pblock     $0000 t2, $1 +  t2, ;
: pdir-middle ( -- ) current-pblock dup $1 -  t2, $1 +  t2, ;
: pdir-last   ( -- ) current-pblock     $1 -  t2, $0000 t2, ;

\ directory entry
: pentry ( -- pentry )
  there $27 $00 tfill, ;

\ unused end space
: punused ( -- )
  $1 $00 tfill, ;

( directory entry )

\ set storage type
: pentry-type! ( storage_type pentry -- )
  pentry>storage_type
  dup t1@ $0f and
  rot $f0 and or
  swap t1! ;

\ store 15 byte prodos filename
: filename! ( ca n ta -- )
  swap dup >r
  0 ?do
    over c@ over t1!
    swap $1 + swap $1 +
  loop
  $f r> - 0 ?do
    $00 over t1!
    $1 +
  loop
  2drop ;

\ set name
: pentry-name! ( ca n pentry -- ) >r
  dup r@ pentry>storage_type
  dup t1@ $f0 and
  rot $0f and or
  swap t1!
  r> pentry>file_name filename! ;

( volume/subdirectory header )

\ increment active files count
: pheader-file+ ( pheader -- )
  pheader>file_count
  dup t2@ $1 + swap t2! ;

( volume directory header )

\ initialize
: pvolume-init ( bytes pvolume -- ) >r
  storage_type.volume r@ pentry-type!
  access.all          r@ pheader>access            t1!
  $27                 r@ pheader>entry_length      t1!
  $0d                 r@ pheader>entries_per_block t1!
  pblock% /           r@ pvolume>total_blocks      t2!
  rdrop ;

( file blocks )

\ create data block
: data-block ( ca n -- ca' n' )
  2dup pblock% umin dup >r
  ts'
  pblock% r@ - $00 tfill,
  swap r@ +
  swap r> - ;

\ store link in index block
: block-link ( block -- )
  dup $8 >> there $100 + t1! t1, ;

\ create index block with links to the next n data blocks
: index-block ( linkedblocks -- )
  current-pblock $1 + over $0 ?do
    dup block-link $1 +
  loop drop
  $100 swap ?do
    $0000 block-link
  loop
  $100 tallot ;

\ create master index block with links to the
\ next n groups of index block plus data blocks
: master-index-block ( linkedblocks -- )
  current-pblock $1 + over $0 ?do
    dup block-link $101 +
  loop drop
  $100 swap ?do
    $0000 block-link
  loop
  $100 tallot ;

( file entry )

\ initialize file entry and update parent header
: pfile-init ( pheader pfile -- ) >r
  access.all    r@ pfile>access         t1!
  dup ta>pblock r@ pfile>header_pointer t2!
  pheader-file+
  rdrop ;

\ set filetype and auxtype
: pfile-type ( filetype auxtype pfile -- ) >r
  r@ pfile>aux_type  t2!
  r@ pfile>file_type t1!
  rdrop ;

\ ceiling division for positive integers
: /ceiling ( n1 n2 -- n3 )
  /mod swap if $1 + then ;

\ store index block and associated data blocks
: pfile-sapling' ( ca n -- ca' n' )
  dup pblock% /ceiling $100 umin
  dup index-block
  $0 ?do
    data-block
  loop ;

\ store master index block and associated
\ index blocks plus data blocks
: pfile-tree' ( ca n -- ca' n' )
  dup [ pblock% $100 * ] literal /ceiling $80 umin
  dup master-index-block
  $0 ?do
    pfile-sapling'
  loop ;

\ store a seedling file
: pfile-seedling ( ca n pfile -- ) >r
  storage_type.seedling r@ pentry-type!
  $1 r> pfile>blocks_used t2!
  data-block 2drop ;

\ store a sapling file
: pfile-sapling ( ca n pfile -- ) >r
  storage_type.sapling r@ pentry-type!
  dup pblock% /ceiling $1 + r> pfile>blocks_used t2!
  pfile-sapling' 2drop ;

\ store a tree file
: pfile-tree ( ca n pfile -- ) >r
  storage_type.tree r@ pentry-type!
  dup pblock% /ceiling
  dup $100 /ceiling +
  $1 + r> pfile>blocks_used t2!
  pfile-tree' 2drop ;

\ add file to image
: pfile-write' ( ca n pfile -- ) >r
  dup r@ pfile>eof t3!
  there ta>pblock r@ pfile>key_pointer t2!
  dup     $200 <= if r> pfile-seedling exit then
  dup   $20000 <= if r> pfile-sapling  exit then
  dup $1000000 <  if r> pfile-tree     exit then
  true abort" file length too large" ;

\ create image file from segment
: pfile-write ( segment pfile -- ) >r
  dup segment>data @
  swap segment>here @
  r> pfile-write' ;

\ create image file from host file
: pfile-host ( ca n pfile -- ) >r
  slurp-file
  r> pfile-write' ;

( volume bitmap )

\ allocate and zero bitmap blocks
: pbitmap ( bytes -- pbitmap )
  there swap
  pblock% /ceiling [ pblock% $8 * ] literal /ceiling
  pblocks $00 tfill, ;

\ write free blocks to bitmap and link from volume header
: pbitmap-write ( pvolume pbitmap -- )
  there >r torg

  there ta>pblock over pvolume>bit_map_pointer t2!
  pvolume>total_blocks t2@

  r@ ta>pblock
  dup -rot - swap

  $8 /mod $00 tfill,
  dup if $00ff over >> t1, then
  dup if negate $8 + - else drop then
  $8 /mod $ff tfill,
  dup if $ff00 over >> t1, then
  drop

  r> torg ;

